home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 090 / pctmay86.arc / COMPILE.PAS < prev    next >
Pascal/Delphi Source File  |  1986-03-04  |  4KB  |  133 lines
  1.  
  2. procedure error(message: maxstr);
  3. begin
  4.   writeln('error in regular.com: ',message);
  5.   halt;          { stop the program }
  6. end;
  7.  
  8. function dodash(var expand: maxstr) : boolean;
  9. {
  10.    Expand character class like "a-h" to "abcdefgh".
  11.    If syntax is wrong, DODASH returns false and all subsequent DASH 
  12.    operators are interpreted as literal characters.
  13. }
  14. var st: maxstr; count: integer;
  15. begin
  16.   dodash:=false;
  17.   st:='';
  18.   if expand[1]>='0' then
  19.     if expand[3]<='z' then
  20.        if expand[1]<expand[3] then
  21.          begin
  22.            for count:=ord(expand[1]) to ord(expand[3]) do st:=st+chr(count);
  23.            expand:=st;
  24.            dodash:=true;
  25.          end;
  26. end;
  27.  
  28. function getccl(class: maxstr) : maxstr;
  29. {
  30.    Convert character class to internal form by removing brackets and
  31.    expanding all DASH operators.  The internal form is
  32.    <prefix character> <n> <char 1> <char 2> ... <char n> where prefix is
  33.    CCL for positive character class and NCCL for negative character class.
  34. }
  35. var encoded, part1, part2, expand: maxstr; PREFIX: char; dash_spot: integer;
  36. begin
  37.    encoded:=copy(class,2,length(class)-2);  {drop CCL and CCLEND}
  38.    if encoded[1]=NEGATE then
  39.       begin
  40.          PREFIX:=NCCL;  delete(encoded,1,1);
  41.       end
  42.          else PREFIX:=CCL;
  43.  
  44.    dash_spot:=pos(DASH,encoded);
  45.  if dash_spot<length(encoded) then
  46.    while dash_spot>1 do
  47.      begin
  48.         part1:=copy(encoded,1,dash_spot-2);
  49.         part2:=copy(encoded,dash_spot+2,length(encoded));
  50.         expand:=copy(encoded,dash_spot-1,dash_spot+1);
  51.         if dodash(expand) then
  52.           begin
  53.              if length(part1)+length(part2)+length(expand)>255
  54.                        then error('regular expression too complex');
  55.               encoded:=part1+expand+part2;
  56.              dash_spot:=pos(DASH,encoded);
  57.           end
  58.              else dash_spot:=0; { DASH syntax wrong. Terminate loop }
  59.       end; {while}
  60.    getccl:=PREFIX+chr(length(encoded))+encoded;
  61. end;
  62.  
  63. function nextpat(var arg, pattern: maxstr) : boolean;
  64. (*
  65.   Delete next pattern from input string ARG and return it in PATTERN.
  66.   ' '..'}' is the set of all literal characters.
  67. *)
  68. var class_length: integer;
  69. begin
  70.    nextpat:=false;
  71.    if arg='' then exit;
  72.    case arg[1] of
  73.             ESCAPE: begin
  74.                       if length(arg)=1 then arg:=arg+ESCAPE;
  75.                       pattern:=copy(arg,1,2);
  76.                       delete(arg,1,2);
  77.                     end;
  78.               CCL: begin
  79.                     pattern:='';
  80.                     class_length:=pos(CCLEND,arg);
  81.                     if class_length<3 then
  82.                       begin
  83.                          pattern:=ESCAPE;
  84.                          class_length:=1;
  85.                       end;
  86.                     pattern:=pattern+copy(arg,1,class_length);
  87.                     delete(arg,1,class_length);
  88.                    end;
  89.      ANY,BOL,EOL, CLOSURE, ' '..'}':
  90.                  begin
  91.                    pattern:=arg[1];
  92.                    delete(arg,1,1);
  93.                  end
  94.               else error('nextpat');
  95.         end; {case}
  96.     nextpat:=true;
  97. end;
  98.  
  99. procedure literal(var pat: maxstr; ch: char);
  100. { Internal format for a literal character.  ex. "C" --> "@C" }
  101. begin
  102.   pat:=pat+LITCHAR+ch;
  103. end;
  104.  
  105. function makepat(entered_arg: maxstr): maxstr;
  106. {
  107.   Takes input parameter ENTERED_ARG and returns internal form. To
  108.   encode a closure, the CLOSURE character must be inserted before
  109.   the last pattern in the PAT string.  The starting position of the
  110.   last pattern is held in OLD_LENGTH.
  111. }
  112. var pat, arg, pattern: maxstr; old_length, new_length: integer;
  113. begin
  114.    pat:='';  arg:=entered_arg;  old_length:=0;  new_length:=0;
  115.    while nextpat(arg,pattern) do
  116.     begin
  117.       case pattern[1] of
  118.      ESCAPE: pat:=pat+LITCHAR+pattern[2];
  119.         ANY: pat:=pat+ANY;
  120.         BOL: if pat='' then pat:=BOL else literal(pat,BOL);
  121.         EOL: if arg='' then pat:=pat+EOL else literal(pat,EOL);
  122.         CCL: pat:=pat+getccl(pattern);
  123.     CLOSURE: if new_length=0 then literal(pat,CLOSURE)
  124.                    else
  125.                     insert(CLOSURE,pat,old_length+1);
  126.             else literal(pat,pattern);
  127.          end; {case}
  128.        old_length:=new_length;
  129.        new_length:=length(pat);
  130.      end; {while}
  131.      makepat:=pat;
  132. end;
  133.